home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / gnu / GNU_TILE_FORTH.lha / src / string.v < prev   
Text File  |  1992-05-19  |  3KB  |  141 lines
  1. /*
  2.   C BASED FORTH-83 MULTI-TASKING KERNEL: NULL TERMINATED STRINGS
  3.  
  4.   Copyright (C) 1988-1990 by Mikael R.K. Patel
  5.  
  6.   Computer Aided Design Laboratory (CADLAB)
  7.   Department of Computer and Information Science
  8.   Linkoping University
  9.   S-581 83 LINKOPING
  10.   SWEDEN
  11.  
  12.   Email: mip@ida.liu.se
  13.  
  14.   Started on: 30 June 1988
  15.  
  16.   Last updated on: 7 September 1990
  17.  
  18.   Dependencies:
  19.     (cc) kernel.c, kernel.h
  20.  
  21.   Description:
  22.     Null terminated string extension vocabulary for the tile forth
  23.     multi-tasking kernel.
  24.  
  25.   Copying:
  26.        This program is free software; you can redistribute it and/or modify
  27.        it under the terms of the GNU General Public License as published by
  28.        the Free Software Foundation; either version 1, or (at your option)
  29.        any later version.
  30.  
  31.        This program is distributed in the hope that it will be useful,
  32.        but WITHOUT ANY WARRANTY; without even the implied warranty of
  33.        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  34.        GNU General Public License for more details.
  35.  
  36.        You should have received a copy of the GNU General Public License
  37.        along with this program; see the file COPYING.  If not, write to
  38.        the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  39.  
  40. */
  41.  
  42. VOID doparenquote()
  43. {
  44.     spush(*ip++, INT32);
  45. }
  46.  
  47. COMPILATION_CODE(parenquote, forth, "(\")", doparenquote);
  48.  
  49. VOID doquote()
  50. {
  51.     /* Scan for the string */
  52.     (VOID) io_scan(thetib, '"');
  53.  
  54.     /* Make a copy of it */
  55.     spush(thetib, CSTR);
  56.     dosdup();
  57.     snip();
  58.  
  59.     /* If compilation mode then thread a string literal */
  60.     if (state.parameter) {
  61.     spush(&parenquote, CODE_ENTRY);
  62.     dothread();
  63.     docomma();
  64.     }
  65. }
  66.  
  67. IMMEDIATE_CODE(quote, parenquote, "\"", doquote);
  68.  
  69. VOID doslength()
  70. {
  71.     tos.INT32 = (INT32) strlen(tos.CSTR);
  72. }
  73.  
  74. NORMAL_CODE(slength, quote, "$length", doslength);
  75.  
  76. VOID dosallot()
  77. {
  78.     tos.CSTR = (CSTR) malloc((unsigned) tos.NUM32);
  79. }
  80.  
  81. NORMAL_CODE(sallot, slength, "$allot", dosallot);
  82.  
  83. VOID dosdup()
  84. {
  85.     spush((CSTR) strcat((char *) malloc((unsigned) strlen(tos.CSTR) + 1), tos.CSTR), CSTR);
  86. }
  87.  
  88. NORMAL_CODE(sdup_entry, sallot, "$dup", dosdup);
  89.  
  90. VOID dosfree()
  91. {
  92.     CSTR s;
  93.  
  94.     s = spop(CSTR);
  95.     free(s);
  96. }
  97.  
  98. NORMAL_CODE(sfree, sdup_entry, "$free", dosfree);
  99.  
  100. VOID dosequal()
  101. {
  102.     CSTR s;
  103.  
  104.     s = spop(CSTR);
  105.     tos.INT32 = (STREQ(tos.CSTR, s) ? TRUE : FALSE);
  106. }
  107.  
  108. NORMAL_CODE(sequal, sfree, "$equal", dosequal);
  109.  
  110. VOID doscompare()
  111. {
  112.     CSTR s;
  113.  
  114.     s = spop(CSTR);
  115.     tos.INT32 = (INT32) strcmp(tos.CSTR, s);
  116. }
  117.  
  118. NORMAL_CODE(scompare, sequal, "$cmp", doscompare);
  119.  
  120. VOID doscat()
  121. {
  122.     CSTR s1, s2;
  123.  
  124.     s2 = spop(CSTR);
  125.     s1 = spop(CSTR);
  126.     (VOID) strcat(s2, s1);
  127. }
  128.  
  129. NORMAL_CODE(scat, scompare, "$cat", doscat);
  130.  
  131. VOID dosprint()
  132. {
  133.     CSTR s;
  134.  
  135.     s = spop(CSTR);
  136.     (VOID) fprintf(io_outf, "%s", s);
  137. }
  138.  
  139. NORMAL_CODE(sprint, scat, "$print", dosprint);
  140.  
  141.